C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
C *****************************
C *  Note:  The following macro definition should be set to the
C *         maximum number of symbols expected in any single
C *         program-unit.  On a virtual-memory system, it can
C *         be set to the maximum number of symbols possible,
C *         i.e.    "define(max_pu_syms,max_symbols)"
C *
C *         For non-virtual systems, this may take up too much space,
C *         so make it smaller, e.g.
C *                 "define(max_pu_syms,500)"
C *****************************
C * The following setting is in use at NAG Central Office:
        PROGRAM ISTVA
 
        COMMON/VXSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(5003),NSYMS
 
        COMMON/VXHEAD/HEADER,DATE,PART
 
        INTEGER HEADER(81),SYMPTH(81),LSTPTH(81),I,
     +          YY,MMM,DD,HH,MM,SS,MILLI,ATRPTH(81),IODATR,IODSYM,
     +          DATE(81),PART,IODLST
 
        INTEGER GETARG,OPEN,CREATE
        EXTERNAL GETARG,OPEN,CREATE,ZYINSY,ZINIT,ZQUIT,ZTIME,ZTIMST,
     +           REMARK,ERROR,ZYXRAB,CLOSE,ZYGSSI
 
        CALL ZINIT
 
        IF (GETARG(1,SYMPTH,81).EQ.-100) CALL NAMES(1,SYMPTH)
        IF (GETARG(2,ATRPTH,81).EQ.-100) CALL NAMES(2,ATRPTH)
        IF (GETARG(3,LSTPTH,81).EQ.-100) CALL NAMES(3,LSTPTH)
        IF (GETARG(4,HEADER,81).EQ.-100) CALL NAMES(4,HEADER)
 
        IF (SYMPTH(1).EQ.45) THEN
            IF (SYMPTH(2).EQ.129) SYMPTH(1)=129
        END IF
        IF (SYMPTH(1).NE.129) THEN
            IODSYM=OPEN(SYMPTH,0)
            IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol path')
        ELSE
            IODSYM=-1
        END IF
        IODATR=OPEN(ATRPTH,0)
        IF (IODATR.EQ.-1) CALL ERROR('Can''t open attribute file')
        IODLST=CREATE(LSTPTH,1)
        IF (IODLST.EQ.-1) CALL ERROR('Can''t create list path')
 
        IF (IODSYM.NE.-1) CALL ZYINSY(IODSYM)
        CALL ZYXRAB(IODATR)
        CALL CLOSE(IODATR)
        CALL ZTIME(YY,MMM,DD,HH,MM,SS,MILLI)
        CALL ZTIMST(YY,MMM,DD,HH,MM,SS,DATE)
 
        IF (IODSYM.NE.-1) THEN
            PART=1
            CALL VXSKIP(0,IODLST)
            I=1
 
 100        CALL ZYGSSI(SYMIDX,NSYMS,I)
            IF (NSYMS.NE.0) THEN
                CALL GETDAT
                CALL SRTIDX
                CALL PRINTS(IODLST)
                I=I+1
                GO TO 100
            END IF
        END IF
 
        PART=2
        CALL VXSKIP(0,IODLST)
 
        CALL OUTPU(IODLST)
        CALL OUTCOM(IODLST)
        CALL OUTEXT(IODLST)
 
        CALL REMARK('[ISTVA Normal Termination]')
        CALL ZQUIT(-2)
 
        END
C ----------------------------------------------------------------------
C
C       N A M E S   -   Input names of files and so on
C
 
        SUBROUTINE NAMES(NUMBER,STRING)
        INTEGER NUMBER,STRING(81)
 
        INTEGER PROMPT(23,4)
 
        SAVE PROMPT
 
        INTEGER ZGTCMD
        EXTERNAL ZPRMPT,ZGTCMD,ERROR
 
C "Input symbol table: "
C "Input attribute file: "
C "Output listing file: "
C "Header text: "
 
        DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
     +121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/,
     +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,97,
     +116,116,114,105,98,117,116,101,32,102,105,108,101,
     +58,32,129/,
     +       (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
     +108,105,115,116,105,110,103,32,102,105,108,101,
     +58,32,129/,
     +       (PROMPT(I,4),I=1,14)/72,101,97,100,101,114,32,
     +116,101,120,116,58,32,129/
 
        CALL ZPRMPT(PROMPT(1,NUMBER))
        IF (ZGTCMD(STRING,0).EQ.-1) CALL ERROR('ZGTCMD failed')
 
        END
C ----------------------------------------------------------------------
C
C       G E T D A T   -   Get symbol data
C
 
        SUBROUTINE GETDAT
 
        COMMON/VXSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(5003),NSYMS
 
        COMMON/VXSYMD/SYMBOL
        INTEGER SYMBOL(8,5003)
 
        INTEGER I
 
        DO 100 I=1,NSYMS
            CALL ZYGTSY(SYMIDX(I),SYMBOL(1,I))
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       S R T I D X   -   Sort symbol index
C
C       Sort key: Symbol type (then) Current position
C                 (Current position is as sorted by name)
C
 
        SUBROUTINE SRTIDX
 
        COMMON/VXSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(5003),NSYMS
 
        COMMON/VXSYMD/SYMBOL
        INTEGER SYMBOL(8,5003)
 
        INTEGER I,J,K,TMP(8),T,ITMP
 
C We will use a form of straight insertion
        DO 600 I=2,NSYMS
            J=I-1
C while J>1 and a(i).lt.a(j) do j=j-1
 100        IF (SYMBOL(1,I) .LT. SYMBOL(1,J)) THEN
                J=J-1
                IF (J.GE.1) GOTO 100
            END IF
            J=J+1
            ITMP=SYMIDX(I)
            DO 200 T=1,8
                TMP(T)=SYMBOL(T,I)
 200        CONTINUE
            DO 400 K=I,J+1,-1
                SYMIDX(K)=SYMIDX(K-1)
                DO 300 T=1,8
                    SYMBOL(T,K)=SYMBOL(T,K-1)
 300            CONTINUE
 400        CONTINUE
            SYMIDX(J)=ITMP
            DO 500 T=1,8
                SYMBOL(T,J)=TMP(T)
 500        CONTINUE
 600    CONTINUE
        END
C ----------------------------------------------------------------------
C
C       P R I N T S   -   Print Symbols
C
 
        SUBROUTINE PRINTS(IODLST)
        INTEGER IODLST
 
        INTEGER MAXARD
        PARAMETER (MAXARD=10)
 
        COMMON/VXSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(5003),NSYMS
 
        COMMON/VXSYMD/SYMBOL
        INTEGER SYMBOL(8,5003)
 
        INTEGER I,TEXT(134),RESULT(8),PLACE,OFFSET,NSUBS,
     +          LIMIT(2,MAXARD),J,COMPTR,VARPTR
        LOGICAL ADJP,INFP
 
        INTEGER ZYXCUS
        EXTERNAL ZYXCUS,ZCHOUT,PUTCH,ZOBLNK,ZPTINT,ZYXGVL,
     +           ZYXGCV,ZYXGAD
 
        I=0
 100    I=I+1
        IF (SYMBOL(1,I).NE.4) GOTO 100
 
        CALL VXSKIP(1,IODLST)
        CALL ZCHOUT('Program Unit: ',IODLST)
        CALL WRSNAM(I,IODLST)
        IF (SYMBOL(4,I).GT.0) CALL ZCHOUT('FUNCTION',IODLST)
        CALL VXSKIP(1,IODLST)
        CALL WRBITS(SYMBOL(6,I),16,IODLST)
 
        I=1
        IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Labels:',IODLST)
 200        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            CALL ZCHOUT(', Parse tree node ',IODLST)
            CALL ZPTINT(SYMBOL(4,I),1,IODLST)
            CALL VXSKIP(1,IODLST)
            IF (SYMBOL(5,I).NE.0) THEN
                CALL ZOBLNK(16,IODLST)
                CALL ZCHOUT('Referenced by ',IODLST)
                CALL ZPTINT(SYMBOL(5,I),1,IODLST)
                CALL VXMESS(' GOTO statements',IODLST)
            END IF
            IF (SYMBOL(7,I).NE.0) THEN
                CALL ZOBLNK(16,IODLST)
                CALL ZCHOUT('Referenced by ',IODLST)
                CALL ZPTINT(SYMBOL(7,I),1,IODLST)
                CALL VXMESS(' I/O statements (as FORMAT)',IODLST)
            END IF
            IF (MOD(SYMBOL(6,I),1000).NE.0) THEN
                CALL ZOBLNK(16,IODLST)
                CALL ZCHOUT('Ends ',IODLST)
                IF (MOD(SYMBOL(6,I),1000).EQ.1)
     +          THEN
                    CALL VXMESS('a DO loop',IODLST)
                ELSE
                    CALL ZPTINT(
     +MOD(SYMBOL(6,I),1000),1,IODLST)
                    CALL VXMESS(' DO loops',IODLST)
                END IF
            END IF
            IF (SYMBOL(6,I)/1000.NE.0) THEN
                CALL ZOBLNK(16,IODLST)
                CALL ZCHOUT('Referenced by ',IODLST)
                CALL ZPTINT(SYMBOL(6,I)/1000,1,
     +                      IODLST)
                CALL VXMESS(' ASSIGN statements',IODLST)
            END IF
            IF (SYMBOL(5,I)+SYMBOL(6,I)+
     +          SYMBOL(7,I).EQ.0) THEN
                CALL ZOBLNK(16,IODLST)
                CALL VXMESS('Never referenced',IODLST)
            END IF
            I=I+1
            IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS)
     +          GOTO 200
        END IF
        IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Common blocks:',IODLST)
 300        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            CALL ZCHOUT(', Size: ',IODLST)
            CALL ZPTINT(SYMBOL(6,I),1,IODLST)
            CALL VXSKIP(1,IODLST)
            CALL ZOBLNK(16,IODLST)
            COMPTR=SYMIDX(I)
            J=1
            CALL ZCHOUT('Items: ',IODLST)
 350        CALL ZYXGCV(COMPTR,VARPTR)
            CALL ZYGTSY(VARPTR,RESULT)
            CALL ZYGTST(RESULT(2),TEXT)
            IF (MOD(J,8).EQ.0) THEN
                CALL VXSKIP(1,IODLST)
                CALL ZOBLNK(23,IODLST)
            END IF
            CALL PUTLIN(TEXT,IODLST)
            IF (COMPTR.NE.0) THEN
                CALL ZCHOUT(', ',IODLST)
                J=J+1
                GOTO 350
            ELSE
                CALL VXSKIP(1,IODLST)
            END IF
            CALL ZOBLNK(16,IODLST)
            CALL VXMESS('Usage:',IODLST)
            CALL WRBITS(ZYXCUS(SYMIDX(I)),20,IODLST)
            I=I+1
            IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS)
     +          GOTO 300
        END IF
        IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Names (Usage Unknown):',IODLST)
 400        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            CALL VXSKIP(1,IODLST)
            CALL WRBITS(SYMBOL(6,I),16,IODLST)
            I=I+1
            IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS)
     +          GOTO 400
        END IF
C SYMBOL(symbol_type,I) must = S_PU ... skip it
        I=I+1
        IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Variables:',IODLST)
 500        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            IF (SYMBOL(7,I).NE.0) THEN
                CALL ZYXGAD(SYMIDX(I),NSUBS,LIMIT,ADJP,INFP)
                CALL ZCHOUT('Array (',IODLST)
                DO 550 J=1,NSUBS
                    IF (J.GT.1) CALL ZCHOUT(',',IODLST)
                    IF (LIMIT(1,J).LE.LIMIT(2,J)) THEN
                        IF (LIMIT(1,J).NE.1) THEN
                            CALL ZPTINT(LIMIT(1,J),1,IODLST)
                            CALL ZCHOUT(':',IODLST)
                        END IF
                        IF (J.EQ.NSUBS .AND. INFP) THEN
                            CALL ZCHOUT('*',IODLST)
                        ELSE
                            CALL ZPTINT(LIMIT(2,J),1,IODLST)
                        END IF
                    ELSE
                        CALL ZCHOUT('......',IODLST)
                        IF (J.EQ.NSUBS .AND. INFP)
     +                      CALL ZCHOUT(':*',IODLST)
                    END IF
 550            CONTINUE
                CALL ZCHOUT(')',IODLST)
            END IF
            CALL VXSKIP(1,IODLST)
            CALL WRBITS(SYMBOL(6,I),16,IODLST)
            CALL ZYXGVL(SYMIDX(I),PLACE,OFFSET)
            IF (PLACE.GT.0) THEN
                CALL ZOBLNK(16,IODLST)
                CALL ZCHOUT('In common block /',IODLST)
                CALL ZYGTSY(PLACE,RESULT)
                CALL ZYGTST(RESULT(2),TEXT)
                CALL PUTLIN(TEXT,IODLST)
                CALL ZCHOUT('/, offset ',IODLST)
                CALL ZPTINT(OFFSET,1,IODLST)
                CALL VXSKIP(1,IODLST)
            ELSE IF (PLACE.LT.0) THEN
                CALL ZOBLNK(16,IODLST)
                CALL ZCHOUT('Local equivalence class ',IODLST)
                CALL ZPTINT(-PLACE,1,IODLST)
                CALL ZCHOUT(', offset ',IODLST)
                CALL ZPTINT(OFFSET,1,IODLST)
                CALL VXSKIP(1,IODLST)
            END IF
            I=I+1
            IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS)
     +          GOTO 500
        END IF
        IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Parameters:',IODLST)
 600        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            CALL ZCHOUT(', Definition node ',IODLST)
            CALL ZPTINT(SYMBOL(7,I),1,IODLST)
            CALL VXSKIP(1,IODLST)
            CALL WRBITS(SYMBOL(6,I),16,IODLST)
            I=I+1
            IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS)
     +          GOTO 600
        END IF
        IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Procedures:',IODLST)
 700        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            CALL VXSKIP(1,IODLST)
            CALL WRBITS(SYMBOL(6,I),16,IODLST)
            I=I+1
            IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS)
     +          GOTO 700
        END IF
        IF (SYMBOL(1,I).EQ.8 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Statement Functions:',IODLST)
 800        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            CALL ZCHOUT(', defined at parse tree node ',IODLST)
            CALL ZPTINT(SYMBOL(7,I),1,IODLST)
            CALL VXSKIP(1,IODLST)
            CALL WRBITS(SYMBOL(6,I),16,IODLST)
            I=I+1
            IF (SYMBOL(2,I).EQ.8 .AND. I.LE.NSYMS) GOTO 800
        END IF
        IF (SYMBOL(1,I).EQ.9 .AND. I.LE.NSYMS) THEN
            CALL VXMESS('        Entry Points:',IODLST)
 900        CALL ZOBLNK(12,IODLST)
            CALL WRSNAM(I,IODLST)
            CALL VXSKIP(1,IODLST)
            CALL WRBITS(SYMBOL(6,I),16,IODLST)
            I=I+1
            IF (SYMBOL(2,I).EQ.9 .AND. I.LE.NSYMS)
     +          GOTO 900
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       O U T P U   -   Output Program-Unit Information
C
 
        SUBROUTINE OUTPU(IODLST)
        INTEGER IODLST
 
C MAXARG = Maximum number of dummy arguments in a p.u.
C MAXLIN = Maximum line length to use (only affects descendent list)
 
        INTEGER MAXARG,MAXLIN
        PARAMETER (MAXARG=60,MAXLIN=80)
 
        INTEGER DTYPE,CHRLEN,NARGS,ARG(7,MAXARG),I,NAME(134),CULIST,
     +          CUSAGE,DESC,REFTYP,GSYPTR,ARGNUM,GPUPTR,EXTRA,ELIST,
     +          EDESC,COL,LASDES
 
        INTEGER ZYXSU,ZIAND,LENGTH
        EXTERNAL ZYXGPU,ZMESS,ERROR,ZCHOUT,ZPTINT,PUTCH,ZYXGGD,ZYXSU,
     +           ZYXGPA,ZYXGIR,ZIAND,ZYXGEP,ZYXGNA,
     +           ZYXGEN,LENGTH
 
        GPUPTR=-1
        CALL VXMESS('Program Units',IODLST)
        CALL VXMESS('=============',IODLST)
 100    IF (GPUPTR.NE.-1) CALL VXSKIP(1,IODLST)
        CALL ZCHOUT('    ',IODLST)
        CALL ZYXGPU(GPUPTR,NAME,DTYPE,CHRLEN,NARGS,CULIST,DESC,ELIST,
     +                ARG)
        CALL WRNAME(NAME,DTYPE,CHRLEN,IODLST)
        IF (DTYPE.GT.0) CALL ZCHOUT('Function',IODLST)
        CALL VXSKIP(1,IODLST)
        IF (NARGS.GT.MAXARG) CALL ERROR('OUTPU: Too many arguments')
        IF (NARGS.EQ.0 .AND. DTYPE.NE.-3)
     +      CALL VXMESS('        No arguments',IODLST)
        DO 200 I=1,NARGS
            CALL ZCHOUT('        Argument ',IODLST)
            CALL ZPTINT(I,1,IODLST)
            CALL ZCHOUT(': ',IODLST)
            CALL OUTARG(ARG(1,I),12,IODLST)
 200    CONTINUE
 300    IF (CULIST.NE.0) THEN
            CALL ZYXGCU(CULIST,GSYPTR,CUSAGE)
            CALL ZYXGNA(GSYPTR,NAME)
            CALL ZCHOUT('        Common Block /',IODLST)
            CALL PUTLIN(NAME,IODLST)
            CALL ZCHOUT('/',IODLST)
            IF (ZIAND(CUSAGE,16+32+64+
     +                       65536+131072).NE.0) THEN
                CALL ZCHOUT(', updated',IODLST)
            END IF
            CALL VXSKIP(1,IODLST)
            GOTO 300
        END IF
        LASDES=0
        COL=1
 400    IF (DESC.NE.0) THEN
            CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
            IF (REFTYP.EQ.1 .OR. REFTYP.EQ.2) THEN
                CALL ZYXGNA(GSYPTR,NAME)
                IF (LASDES.NE.1 .AND. LASDES.NE.2)
     +          THEN
                    IF (COL.NE.1) CALL VXSKIP(1,IODLST)
                    CALL ZCHOUT('        Calls ',IODLST)
                    COL=15
                ELSE
                    CALL ZCHOUT(', ',IODLST)
                    COL=COL+2
                    IF (COL+LENGTH(NAME).GE.MAXLIN) THEN
                        CALL VXSKIP(1,IODLST)
                        CALL ZOBLNK(14,IODLST)
                        COL=15
                    END IF
                END IF
                LASDES=REFTYP
                CALL PUTLIN(NAME,IODLST)
                COL=COL+LENGTH(NAME)
            ELSE IF (REFTYP.EQ.3 .OR. REFTYP.EQ.4)
     +      THEN
                IF (LASDES.NE.0) THEN
                    LASDES=0
                    CALL VXSKIP(1,IODLST)
                END IF
                CALL ZYXGNA(GSYPTR,NAME)
                CALL ZCHOUT('        ',IODLST)
                CALL PUTLIN(NAME,IODLST)
                CALL VXMESS(' passed out (as an actual argument)',
     +                      IODLST)
            ELSE IF (REFTYP.EQ.5) THEN
                IF (LASDES.NE.0) THEN
                    LASDES=0
                    CALL VXSKIP(1,IODLST)
                    COL=1
                END IF
                CALL ZCHOUT('        Calls argument ',IODLST)
                CALL ZPTINT(ARGNUM,1,IODLST)
                CALL VXSKIP(1,IODLST)
            ELSE IF (REFTYP.EQ.6) THEN
                IF (LASDES.NE.0) THEN
                    LASDES=0
                    CALL VXSKIP(1,IODLST)
                    COL=1
                END IF
                CALL ZCHOUT('        Argument ',IODLST)
                CALL ZPTINT(ARGNUM,1,IODLST)
                CALL VXMESS(' passed out (as an actual argument)',
     +                      IODLST)
            ELSE
                IF (LASDES.NE.0) THEN
                    LASDES=0
                    CALL VXSKIP(1,IODLST)
                    COL=1
                END IF
                CALL ZCHOUT('        ??Unknown descendent type ',IODLST)
                CALL ZPTINT(ARGNUM,1,IODLST)
                CALL VXSKIP(1,IODLST)
            END IF
            GOTO 400
        ELSE IF (COL.NE.1) THEN
            CALL VXSKIP(1,IODLST)
        END IF
 500    IF (ELIST.NE.0) THEN
            CALL ZYXGEP(ELIST,GSYPTR)
            CALL ZYXGEN(GSYPTR,NAME,DTYPE,CHRLEN,NARGS,EXTRA,EDESC,
     +                       ARG)
            CALL ZCHOUT('        ENTRY Point ',IODLST)
            CALL PUTLIN(NAME,IODLST)
            IF (DTYPE.NE.-1) THEN
                CALL ZCHOUT(', ',IODLST)
                CALL WRTYPE(DTYPE,CHRLEN,.TRUE.,IODLST)
            END IF
            CALL VXSKIP(1,IODLST)
            IF (NARGS.EQ.0)
     +          CALL VXMESS('             No arguments',IODLST)
            DO 600 I=1,NARGS
                CALL ZCHOUT('            Argument ',IODLST)
                CALL ZPTINT(I,1,IODLST)
                CALL ZCHOUT(': ',IODLST)
                CALL OUTARG(ARG(1,I),16,IODLST)
 600        CONTINUE
 700        IF (EDESC.NE.0) THEN
                CALL ZYXGGD(EDESC,REFTYP,GSYPTR,ARGNUM)
                IF (REFTYP.EQ.1 .OR. REFTYP.EQ.2)
     +          THEN
                    CALL ZYXGNA(GSYPTR,NAME)
                    CALL ZCHOUT('            ENTRY point calls ',IODLST)
                    CALL PUTLIN(NAME,IODLST)
                    CALL VXSKIP(1,IODLST)
                ELSE IF (REFTYP.EQ.3 .OR.
     +                   REFTYP.EQ.4) THEN
                    CALL ZYXGNA(GSYPTR,NAME)
                    CALL ZCHOUT('            ',IODLST)
                    CALL PUTLIN(NAME,IODLST)
                    CALL VXMESS(
     +' passed out from ENTRY (as an actual argument)',IODLST)
                ELSE IF (REFTYP.EQ.5) THEN
                    CALL ZCHOUT(
     +'            ENTRY point calls argument ',IODLST)
                    CALL ZPTINT(ARGNUM,1,IODLST)
                    CALL VXSKIP(1,IODLST)
                ELSE IF (REFTYP.EQ.6) THEN
                    CALL ZCHOUT('            Argument ',IODLST)
                    CALL ZPTINT(ARGNUM,1,IODLST)
                    CALL VXMESS(' passed out (as an actual argument)',
     +                         IODLST)
                ELSE
                    CALL ZCHOUT('            ?Unknown descendent type ',
     +                          IODLST)
                    CALL ZPTINT(REFTYP,1,IODLST)
                    CALL VXSKIP(1,IODLST)
                END IF
                GOTO 700
            END IF
            GOTO 500
        END IF
 800    IF (DESC.NE.0) THEN
            CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
            IF (REFTYP.EQ.1 .OR. REFTYP.EQ.2) THEN
                CALL ZYXGNA(GSYPTR,NAME)
                CALL ZCHOUT('        Calls ',IODLST)
                CALL PUTLIN(NAME,IODLST)
                CALL VXSKIP(1,IODLST)
            ELSE IF (REFTYP.EQ.3 .OR. REFTYP.EQ.4)
     +      THEN
                CALL ZYXGNA(GSYPTR,NAME)
                CALL ZCHOUT('        ',IODLST)
                CALL PUTLIN(NAME,IODLST)
                CALL VXMESS(' passed out (as an actual argument)',
     +                      IODLST)
            ELSE IF (REFTYP.EQ.5) THEN
                CALL ZCHOUT('        Calls argument ',IODLST)
                CALL ZPTINT(ARGNUM,1,IODLST)
                CALL VXSKIP(1,IODLST)
            ELSE IF (REFTYP.EQ.6) THEN
                CALL ZCHOUT('        Argument ',IODLST)
                CALL ZPTINT(ARGNUM,1,IODLST)
                CALL VXMESS(' passed out (as an actual argument)',
     +                      IODLST)
            ELSE
                CALL ZCHOUT('        ??Unknown descendent type ',IODLST)
                CALL ZPTINT(ARGNUM,1,IODLST)
                CALL VXSKIP(1,IODLST)
            END IF
            GOTO 800
        END IF
        IF (GPUPTR.GT.0) GOTO 100
        CALL VXSKIP(1,IODLST)
 
        END
C ----------------------------------------------------------------------
C
C       O U T A R G   -   Output (pu) argument data
C
 
        SUBROUTINE OUTARG(GPUARG,TABPOS,IODLST)
        INTEGER GPUARG(7),TABPOS,IODLST
 
        INTEGER ARGNUM,DESREC,REFTYP,GSYPTR,NAME(134),INHTYP,ASSOC,
     +          STMTNO,EXTRA
        LOGICAL WRAP
 
        INTEGER ZYXSU
        EXTERNAL ZYXSU,ZYXGPA,ZYXGGD,ZYXGNA,ZYXGIR,
     +           ZCHOUT,ZPTINT,PUTCH,PUTLIN,ZMESS,ZOBLNK
 
        CALL WRTYPE(GPUARG(1+0),GPUARG(1+1),
     +              .TRUE.,IODLST)
        WRAP=.FALSE.
        IF (GPUARG(4).EQ.2) THEN
            IF (GPUARG(1+0).NE.-1)
     +          CALL ZCHOUT(' function',IODLST)
        ELSE IF (GPUARG(1+2).EQ.1) THEN
            CALL ZCHOUT(', re'//'ad-only',IODLST)
        ELSE IF (GPUARG(1+2).EQ.2) THEN
            CALL ZCHOUT(', update',IODLST)
        ELSE
            CALL ZCHOUT(', argument to external subprogram',IODLST)
            WRAP=.TRUE.
        END IF
        IF (GPUARG(1+3).EQ.1 .AND.
     +      GPUARG(1+4).EQ.0 .AND.
     +      (GPUARG(1+0).NE.6 .OR.
     +      GPUARG(1+1).NE.0)) THEN
            CALL ZCHOUT(', ',IODLST)
            IF (WRAP) THEN
                CALL PUTCH(10,IODLST)
                CALL ZOBLNK(TABPOS,IODLST)
            END IF
            CALL ZCHOUT('assumed-size/adjustable array',IODLST)
        ELSE IF (GPUARG(1+3).EQ.1) THEN
            CALL ZCHOUT(', ',IODLST)
            IF (WRAP) THEN
                CALL PUTCH(10,IODLST)
                CALL ZOBLNK(TABPOS,IODLST)
            END IF
            CALL ZCHOUT('array (',IODLST)
            IF (GPUARG(1+1).EQ.0) THEN
                CALL ZPTINT(GPUARG(1+4)/
     +                      ZYXSU(GPUARG(1+0)),1,IODLST)
            ELSE
                CALL ZPTINT(GPUARG(1+4)/
     +                      GPUARG(1+1),1,IODLST)
            END IF
            CALL ZCHOUT(' elements)',IODLST)
        END IF
        CALL VXSKIP(1,IODLST)
        IF (GPUARG(1+5).NE.0) THEN
 100        CALL ZYXGPA(GPUARG(1+5),ARGNUM,DESREC)
            CALL ZOBLNK(TABPOS,IODLST)
            CALL ZCHOUT('passed as argument ',IODLST)
            CALL ZPTINT(ARGNUM,1,IODLST)
            CALL ZCHOUT(' to ',IODLST)
            CALL ZYXGGD(DESREC,REFTYP,GSYPTR,ARGNUM)
            IF (REFTYP.EQ.5) THEN
                CALL ZCHOUT('argument ',IODLST)
                CALL ZPTINT(ARGNUM,1,IODLST)
            ELSE
                CALL ZYXGNA(GSYPTR,NAME)
                CALL PUTLIN(NAME,IODLST)
            END IF
            CALL VXSKIP(1,IODLST)
            IF (GPUARG(1+5).NE.0) GOTO 100
        END IF
        IF (GPUARG(1+6).NE.0) THEN
            CALL ZOBLNK(TABPOS,IODLST)
            CALL ZCHOUT('Actual arguments: ',IODLST)
 200        CALL ZYXGIR(GPUARG(1+6),INHTYP,ASSOC,STMTNO,
     +                        EXTRA)
            IF (INHTYP.EQ.0) THEN
                CALL ZCHOUT('procedure ',IODLST)
                CALL ZYXGNA(ABS(EXTRA),NAME)
                CALL PUTLIN(NAME,IODLST)
            ELSE IF (INHTYP.EQ.1) THEN
                CALL ZCHOUT('expression',IODLST)
            ELSE IF (INHTYP.EQ.3) THEN
                CALL ZCHOUT('argument from common /',IODLST)
                CALL ZYXGNA(ABS(EXTRA),NAME)
                CALL PUTLIN(NAME,IODLST)
                CALL ZCHOUT('/',IODLST)
            ELSE IF (INHTYP.EQ.2) THEN
                CALL ZCHOUT('duplicate of argument ',IODLST)
                CALL ZPTINT(EXTRA,1,IODLST)
            ELSE IF (INHTYP.EQ.4) THEN
                CALL ZCHOUT('statement fn dummy argument',
     +                      IODLST)
            ELSE IF (INHTYP.EQ.5) THEN
                CALL ZCHOUT('DO-loop index',IODLST)
            ELSE
                CALL ZCHOUT('***UNKNOWN***',IODLST)
            END IF
            CALL ZCHOUT(' (from ',IODLST)
            CALL ZYXGNA(ASSOC,NAME)
            CALL PUTLIN(NAME,IODLST)
            CALL ZCHOUT(', statement ',IODLST)
            CALL ZPTINT(STMTNO,1,IODLST)
            CALL VXMESS(')',IODLST)
            IF (GPUARG(1+6).NE.0) THEN
                CALL ZOBLNK(TABPOS+18,IODLST)
                GOTO 200
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       O U T C O M   -   Output common block information
C
 
        SUBROUTINE OUTCOM(IODLST)
        INTEGER IODLST
 
        INTEGER COMLEN,COMTYP,TEXT(134),BLANK(8),COMSAV,COMINI,GCBPTR
 
        SAVE BLANK
 
        INTEGER EQUAL
        EXTERNAL ZYXGCB,ZMESS,PUTCH,ZCHOUT,PUTLIN,EQUAL
 
        DATA BLANK/36,67,79,77,77,79,78,129/
 
        GCBPTR=-1
        CALL ZYXGCB(GCBPTR,TEXT,COMLEN,COMTYP,COMSAV,COMINI)
        CALL VXMESS('Common Blocks',IODLST)
        CALL VXMESS('=============',IODLST)
        IF (GCBPTR.GE.0) THEN
 100        CALL ZCHOUT('    ',IODLST)
            CALL PUTCH(47,IODLST)
            IF (EQUAL(TEXT,BLANK).EQ.-3) CALL PUTLIN(TEXT,IODLST)
            CALL ZCHOUT('/, Length ',IODLST)
            CALL ZPTINT(COMLEN,1,IODLST)
            IF (COMTYP.EQ.0) THEN
                CALL ZCHOUT(', character',IODLST)
            ELSE IF (COMTYP.EQ.1) THEN
                CALL ZCHOUT(', non-character',IODLST)
            ELSE IF (COMTYP.EQ.2) THEN
                CALL ZCHOUT(', mixed (ch'//'ar & other)',IODLST)
            ELSE
                CALL ZCHOUT(', BAD VALUE FOR COMTYP',IODLST)
            END IF
            IF (COMSAV.EQ.2) THEN
                CALL ZCHOUT(', only occurs in main program',IODLST)
            ELSE IF (COMSAV.EQ.1) THEN
                CALL ZCHOUT(', SAVEd in subprograms',IODLST)
            END IF
            IF (COMINI.EQ.1) THEN
                CALL VXMESS(', initialised by BLOCK DATA',IODLST)
            ELSE IF (COMINI.GT.1) THEN
                CALL ZCHOUT(', occurs in ',IODLST)
                CALL ZPTINT(COMINI,1,IODLST)
                CALL VXMESS(' BLOCK DATA subprograms',IODLST)
            ELSE
                CALL VXSKIP(1,IODLST)
            END IF
            IF (GCBPTR.NE.0) THEN
                CALL ZYXGCB(GCBPTR,TEXT,COMLEN,COMTYP,COMSAV,COMINI)
                GOTO 100
            END IF
        ELSE
            CALL VXMESS('    There are n'//'o common blocks...',IODLST)
        END IF
        CALL VXSKIP(1,IODLST)
 
        END
C ----------------------------------------------------------------------
C
C       O U T E X T   -   Output external references
C
 
        SUBROUTINE OUTEXT(IODLST)
        INTEGER IODLST
 
        INTEGER MAXARG
        PARAMETER (MAXARG=60)
C This parameter also appears in SUBROUTINE OUTPU
 
        INTEGER NAME(134),DTYPE,CHRLEN,NARGS,ARGBLK(MAXARG*3),I,J,B,
     +          GEXPTR,INHX,ASSOC,INHTYP,STMTNO,EXTRA
        CHARACTER*13 ATYPE(0:4)
 
        SAVE USAGE
 
        EXTERNAL ZYXGEX,ZMESS,ZCHOUT,ZPTINT,ZYXGIR
 
        DATA ATYPE/'Scalar.      ',
     +             'Array element',
     +             'Array.       ',
     +             'Function.    ',
     +             'Label.       '/
 
        GEXPTR=-1
        CALL ZYXGEX(GEXPTR,NAME,DTYPE,CHRLEN,NARGS,ARGBLK)
        IF (GEXPTR.GE.0) THEN
            CALL VXMESS('External References',IODLST)
            CALL VXMESS('===================',IODLST)
 100        CALL ZCHOUT('    ',IODLST)
            CALL WRNAME(NAME,DTYPE,CHRLEN,IODLST)
            IF (DTYPE.GT.0) CALL ZCHOUT('Function ',IODLST)
            CALL VXSKIP(1,IODLST)
            IF (NARGS.GT.MAXARG) CALL ERROR('OUTEXT: Too many args')
            IF (NARGS.EQ.0) CALL VXMESS('        No arguments',IODLST)
            IF (NARGS.LT.0) CALL VXMESS('        Only passed as arg',
     +                                 IODLST)
            J=1
            DO 200 I=1,NARGS
                B=MOD(ARGBLK(J+0),8)
                CALL ZCHOUT('        Argument ',IODLST)
                CALL ZPTINT(I,1,IODLST)
                CALL ZCHOUT(': ',IODLST)
                DTYPE=ARGBLK(J+0)/8+(-3)
                INHX=ARGBLK(J+1)
                IF (DTYPE.EQ.6) THEN
                    CALL WRTYPE(DTYPE,ARGBLK(J+2),.TRUE.,IODLST)
                    IF (ARGBLK(J+2).NE.ARGBLK(J+3)
     +                  .AND. ARGBLK(J+2).NE.0) THEN
                        CALL ZCHOUT('......(',IODLST)
                        CALL ZPTINT(ARGBLK(J+3),1,IODLST)
                        CALL ZCHOUT(') ',IODLST)
                    END IF
                    J=J+4
                ELSE
                    CALL WRTYPE(DTYPE,0,.TRUE.,IODLST)
                    J=J+2
                END IF
                IF (DTYPE.NE.10 .AND. DTYPE.NE.-1) THEN
                    CALL VXMESS(ATYPE(B),IODLST)
                ELSE
                    CALL VXSKIP(1,IODLST)
                END IF
                IF (INHX.NE.0) THEN
                    CALL ZCHOUT('            Actual arguments: ',IODLST)
 150                CALL ZYXGIR(INHX,INHTYP,ASSOC,STMTNO,EXTRA)
                    IF (INHTYP.EQ.0) THEN
                        CALL ZCHOUT('procedure ',IODLST)
                        CALL ZYXGNA(ABS(EXTRA),NAME)
                        CALL PUTLIN(NAME,IODLST)
                    ELSE IF (INHTYP.EQ.1) THEN
                        CALL ZCHOUT('expression',IODLST)
                    ELSE IF (INHTYP.EQ.3) THEN
                        CALL ZCHOUT('argument from common /',IODLST)
                        CALL ZYXGNA(ABS(EXTRA),NAME)
                        CALL PUTLIN(NAME,IODLST)
                        CALL ZCHOUT('/',IODLST)
                    ELSE IF (INHTYP.EQ.2) THEN
                        CALL ZCHOUT('duplicate of argument ',IODLST)
                        CALL ZPTINT(EXTRA,1,IODLST)
                    ELSE IF (INHTYP.EQ.4) THEN
                        CALL ZCHOUT('statement fn dummy argument',
     +                              IODLST)
                    ELSE IF (INHTYP.EQ.5) THEN
                        CALL ZCHOUT('DO-loop index',IODLST)
                    ELSE
                        CALL ZCHOUT('***UNKNOWN***',IODLST)
                    END IF
                    CALL ZCHOUT(' (from ',IODLST)
                    CALL ZYXGNA(ASSOC,NAME)
                    CALL PUTLIN(NAME,IODLST)
                    CALL ZCHOUT(', statement ',IODLST)
                    CALL ZPTINT(STMTNO,1,IODLST)
                    CALL VXMESS(')',IODLST)
                    IF (INHX.NE.0) THEN
                        CALL ZCHOUT('                              ',
     +                              IODLST)
                        GOTO 150
                    END IF
                END IF
 200        CONTINUE
            IF (GEXPTR.GT.0) THEN
                CALL ZYXGEX(GEXPTR,NAME,DTYPE,CHRLEN,NARGS,ARGBLK)
                GOTO 100
            END IF
        ELSE
            CALL VXMESS('There are n'//'o external references...',
     +                  IODLST)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       W R S N A M   -   Write symbol name and data type if any
C
 
        SUBROUTINE WRSNAM(N,IODLST)
        INTEGER N,IODLST
 
        COMMON/VXSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(5003),NSYMS
 
        COMMON/VXSYMD/SYMBOL
        INTEGER SYMBOL(8,5003)
 
        INTEGER TEXT(134)
 
        EXTERNAL ZYGTST,PUTLIN,ZCHOUT,PUTCH,ZPTINT
 
        CALL ZYGTST(SYMBOL(2,N),TEXT)
        CALL PUTLIN(TEXT,IODLST)
        IF (SYMBOL(1,N).EQ.2 .OR.
     +      SYMBOL(1,N).EQ.1) RETURN
        CALL PUTCH(32,IODLST)
        CALL WRTYPE(SYMBOL(4,N),SYMBOL(5,N),.FALSE.,
     +              IODLST)
        CALL PUTCH(32,IODLST)
 
        END
C ----------------------------------------------------------------------
C
C       W R T Y P E   -   Write data type
C
 
        SUBROUTINE WRTYPE(DTYPE,CHRLEN,GLOBAL,IODLST)
        INTEGER DTYPE,CHRLEN,IODLST
        LOGICAL GLOBAL
 
        CHARACTER*17 TYPTXT(-3:15)
 
        SAVE TYPTXT
 
        EXTERNAL ZCHOUT,PUTCH,ZPTINT
 
        DATA TYPTXT/
     +'PROGRAM.         ',
     +'BLOCK DATA.      ',
     +'SUBROUTINE.      ',
     +'*** UNKNOWN ***. ',
     +'INTEGER.         ',
     +'REAL.            ',
     +'LOGICAL.         ',
     +'COMPLEX.         ',
     +'DOUBLE PRECISION.',
     +'CHARACTER.       ',
     +'DOUBLE COMPLEX.  ',
     +'Generic.         ',
     +'Hollerith.       ',
     +'Label.           ',
     +'Substring spec...',
     +'LOGICAL*1.       ',
     +'LOGICAL*2.       ',
     +'INTEGER*2.       ',
     +'REAL*16.         '/
 
        CALL ZCHOUT(TYPTXT(DTYPE),IODLST)
        IF (CHRLEN.NE.0) THEN
            CALL PUTCH(42,IODLST)
            IF (CHRLEN.GT.0) THEN
                CALL ZPTINT(CHRLEN,1,IODLST)
            ELSE IF (GLOBAL) THEN
                CALL ERROR('Global charlen 60 than zero')
            ELSE
                CALL ZCHOUT('(Node ',IODLST)
                CALL ZPTINT(-CHRLEN,1,IODLST)
                CALL ZCHOUT(')',IODLST)
            END IF
        ELSE IF (GLOBAL .AND. DTYPE.EQ.6) THEN
            CALL ZCHOUT('*(*)',IODLST)
        END IF
        CALL PUTCH(32,IODLST)
 
        END
C ----------------------------------------------------------------------
C
C       W R N A M E   -   Write a (global) name and data type
C
 
        SUBROUTINE WRNAME(NAME,DTYPE,CHRLEN,IODLST)
        INTEGER NAME(*),DTYPE,CHRLEN,IODLST
 
        EXTERNAL PUTLIN,ZCHOUT
 
        CALL PUTLIN(NAME,IODLST)
        IF (NAME(1).EQ.129) CALL ZCHOUT('Indirect reference',IODLST)
        CALL ZCHOUT(': ',IODLST)
        CALL WRTYPE(DTYPE,CHRLEN,.TRUE.,IODLST)
 
        END
C ----------------------------------------------------------------------
C
C       W R B I T S   -   Write meaning of attribute bits
C
 
        SUBROUTINE WRBITS(BITS,TAB,IODLST)
        INTEGER BITS,TAB,IODLST
 
        INTEGER NBITS
        PARAMETER (NBITS=23)
 
        INTEGER I
        CHARACTER*34 BITTXT(NBITS)
 
        SAVE BITTXT
 
        INTEGER ZIAND
        EXTERNAL ZMESS,ZIAND,ZOBLNK
 
        DATA (BITTXT(I),I=1,19)/
     +'Declared EXTERNAL.                ',
     +'Declared INTRINSIC.               ',
     +'Formal parameter.                 ',
     +'Explicitly typed.                 ',
     +'In ASSIGN statement.              ',
     +'Assigned to on left of "=".       ',
     +'In READ input list.               ',
     +'In DATA statement.                ',
     +'Statement function formal param.  ',
     +'In EQUIVALENCE statement.         ',
     +'In COMMON statement.              ',
     +'Used as an actual argument.       ',
     +'Standard intrinsic function.      ',
     +'Called as a function.             ',
     +'In an expression.                 ',
     +'Called as a subroutine.           ',
     +'Used as a DO-loop index.          ',
     +'Actual argument to external.      ',
     +'Parameter value known.            '/
        DATA (BITTXT(I),I=20,NBITS)/
     +'Equivalenced into a common block. ',
     +'In an array declarator.           ',
     +'In INCLUDE file.                  ',
     +'Type declaration has been seen.   '/
 
        DO 100 I=1,NBITS
            IF (ZIAND(BITS,1).NE.0) THEN
                CALL ZOBLNK(TAB,IODLST)
                CALL VXMESS(BITTXT(I),IODLST)
            END IF
            BITS=BITS/2
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       V X S K I P   -   Skip lines on output file
C
 
        SUBROUTINE VXSKIP(N,IODLST)
        INTEGER N,IODLST
 
        INTEGER LPP,MARGIN,TOPMAR
        PARAMETER (LPP=72,MARGIN=6,TOPMAR=4)
 
        COMMON/VXHEAD/HEADER,DATE,PART
        INTEGER HEADER(81),DATE(81),PART
 
        INTEGER I,LINENO
 
        SAVE LINENO
 
        DATA LINENO/0/
 
C (N.EQ.0) => Page eject now
        IF (N.EQ.0 .AND. LINENO.NE.0) THEN
            DO 100 I=LINENO,LPP
                CALL PUTCH(10,IODLST)
 100        CONTINUE
            LINENO=0
        END IF
 
C (LINENO.EQ.0) => at top of page
        IF (LINENO.EQ.0) THEN
C First, output top margin
            DO 200 I=1,TOPMAR
                CALL PUTCH(10,IODLST)
 200        CONTINUE
            LINENO=TOPMAR+1
C Now, output header
            CALL PUTLIN(HEADER,IODLST)
            IF (PART.EQ.1) THEN
                CALL ZCHOUT(': Extended Symbol Table Listing, ',IODLST)
            ELSE
                CALL ZCHOUT(': Global Attribute Listing, ',IODLST)
            END IF
            CALL PUTLIN(DATE,IODLST)
            CALL PUTCH(10,IODLST)
            CALL PUTCH(10,IODLST)
            LINENO=LINENO+2
        END IF
C Ok, now output the blank lines (but not further than the end of page)
        DO 300 I=1,MIN(N,LPP-LINENO)
            CALL PUTCH(10,IODLST)
 300    CONTINUE
        LINENO=LINENO+MIN(N,LPP-LINENO)
C If this brings us into the bottom margin, skip to top of page
        IF (LINENO.GT.LPP-MARGIN) THEN
            DO 400 I=LINENO,LPP
                CALL PUTCH(10,IODLST)
 400        CONTINUE
            LINENO=0
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       V X M E S S   -   Write message to output file
C
 
        SUBROUTINE VXMESS(STRING,IODLST)
        CHARACTER*(*) STRING
        INTEGER IODLST
 
        EXTERNAL ZCHOUT
 
        CALL ZCHOUT(STRING,IODLST)
        CALL VXSKIP(1,IODLST)
 
        END
